home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / mp_eubang.m < prev    next >
Text File  |  1992-07-15  |  28KB  |  1,134 lines
  1. /*
  2.  *    Plurals
  3.  *
  4.  *    Author:    S.C.Merrall
  5.  *
  6.  *    File:    mp_eubang.m
  7.  *
  8.  *    Contents:    mp_make_plural
  9.  *            mp_make_context
  10.  *            mp_plural
  11.  *            mp_init_plural
  12.  *                      mp_length
  13.  *                      mp_match
  14.  *                      mp_move
  15.  *            mp_stat
  16.  *            cm_start
  17.  *            cm_put
  18.  *
  19.  *    Description:       Functions for creating and manipulating plurals.
  20.  *            One major function which acts as a generalised 
  21.  *            interface between the front end and back end. Since
  22.  *            operations have the same general code to convert
  23.  *            from an MP_Plural object address to a set of heap
  24.  *            locations.
  25.  *
  26.  *    Change History:
  27.  *
  28.  *    Date   Name Comment
  29.  *    -------- ---- -------
  30.  *    21:05:91 SCM  Created
  31.  *    23:05:91 SCM  Added mp_error, error indicator to the front end
  32.  *    28:06:91 SCM  Context seperated from plural, connected of FE only
  33.  *    **:02:92 SCM  Function for CM-Lisp v1, cm_identify
  34.  *    **:03:92 SCM  Functions for CM-lisp v2, cm_put, cm_start
  35.  *    26:03:92 SCM  cm_identify removed
  36.  *    06:04:92 SCM  initialise t, nil to be proper objects with special address
  37.  *
  38.  */
  39.  
  40. #include <mpl.h>
  41. #include <stdio.h>
  42. #include "proc_pair.h"
  43.  
  44. #include "mp_eubang.h"    /*  Includes constant.h too */
  45.  
  46. #include "mp_object.h"
  47. #include "mp_debug_off.h"
  48. #include "mp_mem_mgmt.h"
  49. #include "mp_gc.h"
  50. #include "mp_utils.h"
  51.  
  52. visible int private_nproc;      /*  So the host knows how much memory to allocate
  53.              *  for its scratch space */
  54.  
  55. visible int mp_error;    /*  Integer visible to the front end so we can use
  56.              *  it to indicate the error that has occurred.
  57.              */ 
  58.  
  59.  
  60. /*----------------------------------------------------------------------------*
  61.  * Function   : mp_make_context
  62.  *
  63.  * Parameters : int width:    Width of the context
  64.  *        int height:    Height of the context
  65.  *
  66.  * Description: Creates a context handle. identifies a rectangular set of
  67.  *        processors and allocates a new context stack on them.
  68.  *        When a non rectangular set is requested the front end lisp
  69.  *        will munge the context stack to deactivate extra elements.
  70.  *
  71.  * Result     : char *:    Address of context handle
  72.  *---------------------------------------------------------------------------*/
  73.  
  74. #ifdef __STDC__
  75.  
  76. visible char *mp_make_context( int width, int height )
  77.  
  78. #else
  79.  
  80. visible char *mp_make_context( width, height )
  81.  
  82. int width;
  83. int height;
  84.  
  85. #endif
  86.  
  87. {
  88.   object MPC_new;
  89.   MP_PluralHeap MPPH_context_stack;
  90. DBG_CALL("mp_make_context");
  91. DBG_ARGS(fprintf(dbg,"width=%d, height=%d",width,height));
  92.   set_gc_message();
  93.  
  94.   mp_error = MP_GREEN;
  95.  
  96.  
  97.   PP_on_set() {
  98.  
  99.     if ((MPC_new = OF_create(OC_MP_Context)(width,height)) == NULL) {
  100.  
  101. DBG_FAIL(fprintf(dbg,"FAIL: Unable to allocate new context"));
  102.       mp_error = MP_ALLOC_CONTEXT_FAILED;
  103.     }
  104.     else OM_with_context(MPC_new) {
  105.  
  106.       MPP_2_MPPH(MPPH_context_stack, OA_offset(MPC_new));
  107.     
  108.       if (make_context_stack( MPPH_context_stack ) == FAIL) {
  109.  
  110. DBG_FAIL(fprintf(dbg,"FAIL: Unable to build new context stack"));
  111.         mp_error = MP_MAKE_STACK_FAILED;
  112.       }
  113.     }
  114.   }
  115.   
  116.   if (mp_error) return FAIL;
  117.  
  118. DBG_EXIT(fprintf(dbg,"%x",MPC_new));
  119.   return (char *) MPC_new;
  120. }
  121.  
  122.  
  123. /*----------------------------------------------------------------------------*
  124.  * Function   : mp_make_plural
  125.  *
  126.  * Parameters : object MPC_context:    MasPar Context object
  127.  *
  128.  * Description: Creates a new plural with context MPC_context. That is it finds
  129.  *        an offset in the plural space such that on all the processors
  130.  *        in MPC_context that offset is free. Marks the offsets as not
  131.  *        being free and returns the offset
  132.  *
  133.  * Result     : int :     Offset/FAIL
  134.  *---------------------------------------------------------------------------*/
  135.  
  136. #ifdef __STDC__
  137.  
  138. visible int mp_make_plural( object MPC_context )
  139.  
  140. #else
  141.  
  142. visible int mp_make_plural( MPC_context )
  143.  
  144. object MPC_context;
  145.  
  146. #endif
  147.  
  148. {
  149.   int result;
  150. DBG_CALL("mp_make_plural");
  151. DBG_ARGS(fprintf(dbg,"MPC_context=%x",MPC_context));
  152.   set_gc_message();
  153.  
  154.   mp_error = MP_GREEN;
  155.  
  156.   PP_on_set() {
  157.  
  158.     if ((result = (int) alloc_plural(MPC_context)) == FAIL) {
  159.  
  160. DBG_FAIL(fprintf(dbg,"FAIL: Unable to allocate new plural"));
  161.     mp_error = MP_ALLOC_PLURAL_FAILED;
  162.     }
  163.   }
  164.  
  165.   if (mp_error) return FAIL;
  166.  
  167. DBG_EXIT(fprintf(dbg,"%d",result));
  168.   return result;
  169. }
  170.  
  171. /*----------------------------------------------------------------------------*
  172.  * Function   : mp_plural
  173.  *
  174.  * Parameters : int operation_id:    Unique identifier of the desired 
  175.  *                    operation.
  176.  *        int no_of_args:        How many args have been supplied.
  177.  *        int no_of_addresses:    How many of the args are mp_object
  178.  *                    addresses, (this will all be together
  179.  *                    at the beginning;
  180.  *        char * arg1:        Each arg is a 32-bit word, representing
  181.  *                    either an object address, an
  182.  *                    integer or a front end address.
  183.  *                    This is determined by the operation
  184.  *                ...    
  185.  *
  186.  * Description:    Wrapper for all functions. Most operations require 
  187.  *        converting an MasPar Plural object into a MasPar Plural
  188.  *        Heap objec (that is a handle on the plurals heap space) and
  189.  *        calling the appropriate lisp primitive.
  190.  *
  191.  * Result     : char *:        Again a 32-bit word which may be the address
  192.  *                of a new object or an integer representing
  193.  *                the result of the function. NULL usually
  194.  *                indicates FAIL. 
  195.  *---------------------------------------------------------------------------*/
  196.  
  197. #ifdef __STDC__
  198.  
  199. visible int    mp_plural(object MPC_context,
  200.              int operation_id,   
  201.              int no_of_args,     
  202.              int no_of_offsets,
  203.              int arg1,
  204.              int arg2,
  205.              int arg3 )
  206.  
  207. #else
  208.  
  209. visible int   mp_plural( MPC_context, operation_id, no_of_args, no_of_offsets,
  210.              arg1, arg2, arg3 )
  211.  
  212. object MPC_context;
  213. int operation_id;
  214. int no_of_args;
  215. int no_of_offsets; 
  216. int arg1;
  217. int arg2;
  218. int arg3;
  219.  
  220. #endif
  221.  
  222. {
  223.   natural pe_x, pe_y;
  224.   int result_status = SUCCESS;
  225.   int return_value  = NULL;
  226.   plural natural result_offsets = NIL;
  227.   plural natural context;
  228.   MP_PluralHeap MPPH_arg1;
  229.   MP_PluralHeap MPPH_arg2;
  230.   MP_PluralHeap MPPH_arg3;
  231.   MP_PluralHeap MPPH_result = &result_offsets;
  232.   MP_PluralHeap MPPH_context_stack;
  233.   MP_PluralHeap MPPH_context = &context;
  234.   char local_gc_message[60];
  235. DBG_CALL("mp_plural");
  236. DBG_ARGS(fprintf(dbg,"MPC_context=%x, operation_id=%d, no_of_args=%d, no_of_offsets=%d", MPC_context,operation_id, no_of_args, no_of_offsets));
  237.   GC_Protect(result_offsets);
  238.   sprintf(local_gc_message,"mp_plural,op_id=%d",operation_id);
  239.   gc_message=local_gc_message;
  240.   
  241.   /* Convert addresses to MasPar Plural Heap objects */
  242.  
  243.   if (no_of_offsets >= 1) MPP_2_MPPH(MPPH_arg1,arg1);
  244.   if (no_of_offsets >= 2) MPP_2_MPPH(MPPH_arg2,arg2);
  245.   if (no_of_offsets >= 3) MPP_2_MPPH(MPPH_arg3,arg3);
  246.  
  247.   scratch[0] = NULL;
  248.   if (operation_id == MP_X_STAT) scratch[0] = 0;
  249.  
  250.   PP_on_set() {
  251.     
  252.     if (operation_id == MP_X_STAT) scratch[0] = 1;
  253.  
  254.   OM_with_context(MPC_context) {
  255.  
  256.     if (operation_id == MP_X_STAT) scratch[0] = 2;
  257.  
  258.     /* Extract the current context */
  259.     
  260.     MPP_2_MPPH(MPPH_context_stack, OA_offset(MPC_context));
  261.     if (car(MPPH_context_stack, MPPH_context) == FAIL) {
  262.  
  263. DBG_FAIL(fprintf(dbg,"FAIL: Unable to take car of context stack, op_id=%d",operation_id));
  264. DBG_EROR(MP_CAR_OF_CONTEXT_FAIL);
  265.     }
  266.  
  267.     if (operation_id == MP_IF) {
  268.  
  269.       /* Result_status is either FAIL, MP_NONE_ACTIVE, MP_SOME_ACTIVE */
  270.  
  271. DEBUG(DBG_PARG("ps[2589]","%d ",plural_memory[2589]));    
  272.       if ((result_status = mp_if(MPPH_arg1, MPPH_context_stack)) == FAIL) {
  273.  
  274.     mp_error = MP_IF_FAILED;
  275.       }
  276.       else return_value =  result_status;
  277. DEBUG(DBG_PARG("ps[2589]","%d ",plural_memory[2589]));    
  278.     }
  279.     else if (operation_id == MP_ELIF) {
  280.  
  281.       if ((result_status = mp_elif( MPPH_context_stack)) == FAIL) 
  282.     mp_error = MP_ELIF_FAILED;
  283.       else return_value - result_status;
  284.     }
  285.     else if (operation_id == MP_FI) {
  286.       
  287.       if ((result_status = mp_fi(MPPH_context_stack)) == FAIL) {
  288.  
  289.     mp_error = MP_FI_FAILED;
  290.       }
  291.     }
  292.     else if (operation_id == MP_ELSE) {
  293.  
  294.       if ((result_status = mp_else(MPPH_context_stack)) == FAIL) {
  295.  
  296.     mp_error = MP_ELSE_FAILED;
  297.       }
  298.       else return_value = result_status;
  299.     }
  300.     else if (operation_id == MP_CONTEXT) {
  301.  
  302.       return_value = OA_offset(MPC_context);
  303.       result_status = SUCCESS;
  304.     }
  305.     /* Operate conditionally on current context */
  306.  
  307.     else if (OA_offsets(MPPH_context) != NIL) {
  308.  
  309.       switch (operation_id) {
  310.  
  311.       case MP_PRINT :
  312.  
  313.     print( MPPH_arg1, (plural int) 0 );
  314.     result_status = SUCCESS;
  315.     return_value =  arg1;
  316.     break;
  317.  
  318.       case MP_X_STAT :
  319.  
  320.     if( OA_offsets(MPPH_arg1) != NIL) scratch[0]=3;
  321.     result_status = SUCCESS;
  322.     return_value = arg1;
  323.      break;
  324.  
  325.       case MP_TEST :
  326.  
  327.     if ((result_status = test(MPPH_arg1,
  328.                   (plural int)arg2,MPPH_result))==FAIL) {
  329.  
  330.       mp_error = MP_TEST_FAILED;
  331.     }
  332.     break;
  333.  
  334.       case MP_EQ :
  335.  
  336.     if ((result_status = eq(MPPH_arg1,MPPH_arg2,MPPH_result)) == FAIL) {
  337.  
  338.       mp_error = MP_EQ_FAILED;
  339.     }
  340.     break;
  341.  
  342.       case MP_AND :
  343.  
  344.     if ((result_status = and(MPPH_arg1,MPPH_arg2,MPPH_result)) == FAIL) {
  345.  
  346.       mp_error = MP_AND_FAILED;
  347.     }
  348.     break;
  349.  
  350.       case MP_OR :
  351.  
  352.     if ((result_status = or(MPPH_arg1,MPPH_arg2,MPPH_result)) == FAIL) {
  353.  
  354.       mp_error = MP_OR_FAILED;
  355.     }
  356.     break;
  357.  
  358.       case MP_NOT :
  359.     
  360.     if ((result_status = not(MPPH_arg1,MPPH_result)) == FAIL)
  361.       mp_error = MP_NOT_FAILED;
  362.     break;
  363.  
  364.       case MP_MP_CONS :
  365.     
  366.     if ((result_status = cons(MPPH_arg1,MPPH_arg2,MPPH_result)) == FAIL) {
  367.  
  368.       mp_error = MP_CONS_FAILED;
  369.     }
  370.     break;
  371.  
  372.       case MP_CAR :
  373.  
  374.     if ((result_status = car(MPPH_arg1,MPPH_result)) == FAIL) {
  375.  
  376.       mp_error = MP_CAR_FAILED;
  377.     }
  378.     break;
  379.  
  380.       case MP_CDR :
  381.  
  382.     if ((result_status = cdr(MPPH_arg1,MPPH_result)) == FAIL) {
  383.  
  384.       mp_error = MP_CDR_FAILED;
  385.     }
  386.     break;
  387.  
  388.       case MP_RPLAC_A :
  389.  
  390.     if ((result_status = rplac_a(MPPH_arg1,MPPH_arg2)) == FAIL) {
  391.  
  392.       mp_error = MP_RPLAC_A_FAILED;
  393.     }
  394.     break;
  395.  
  396.       case MP_RPLAC_D :
  397.  
  398.     if ((result_status = rplac_d(MPPH_arg1,MPPH_arg2)) == FAIL) {
  399.  
  400.       mp_error = MP_RPLAC_A_FAILED;
  401.     }
  402.     break;
  403.  
  404.       case MP_INT_BIN_OP :
  405.  
  406.     if ((result_status = int_bin_op(MPPH_arg1,MPPH_arg2,(plural int) arg3,
  407.                       MPPH_result)) == FAIL) {
  408.         
  409.       mp_error = MP_INT_BIN_OP_FAILED;
  410.     }
  411.     break;
  412.  
  413.       case MP_BIN_OP :
  414.  
  415. DEBUG(fprintf(dbg,"arg1:%d: ",arg1);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg1)));
  416. DEBUG(fprintf(dbg,"arg2:%d: ",arg2);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg2)));
  417.  
  418.     if ((result_status = bin_op(MPPH_arg1,MPPH_arg2,(plural int) arg3,
  419.                     MPPH_result)) == FAIL) {
  420.         
  421.       mp_error = MP_BIN_OP_FAILED;
  422.     }
  423.     break;
  424.  
  425.       case MP_REL_OP :
  426.  
  427.     if ((result_status = rel_op(MPPH_arg1,MPPH_arg2,(plural int) arg3,
  428.                     MPPH_result)) == FAIL) {
  429.         
  430.       mp_error = MP_REL_OP_FAILED;
  431.     }
  432.     break;
  433.  
  434.       case MP_UN_OP :
  435.  
  436.     if ((result_status = un_op(MPPH_arg1, (plural int) arg2, 
  437.                    MPPH_result)) == FAIL) {
  438.  
  439.       mp_error = MP_UN_OP_FAILED;
  440.     }
  441.     break;
  442.  
  443.       case MP_SCAN_OP :
  444.  
  445.     if ((result_status = scan_op(MPPH_arg1, (int) arg2, 
  446.                    MPPH_result)) == FAIL) {
  447.  
  448.       mp_error = MP_UN_OP_FAILED;
  449.     }
  450.     break;
  451.  
  452.       case MP_RANDOM :
  453.  
  454.     if ((result_status = rnd(MPPH_result)) == FAIL) 
  455.       mp_error = MP_RND_FAILED;
  456.     break;
  457.  
  458.       case MP_MAKE_VECTOR :
  459.  
  460.     if ((result_status = make_vector(MPPH_arg1, MPPH_result)) == FAIL) {
  461.  
  462.       mp_error = MP_MAKE_VECTOR_FAILED;
  463.     }
  464.     break;
  465.  
  466.       case MP_VECTOR_LENGTH :
  467.  
  468.     if ((result_status = vector_length(MPPH_arg1, MPPH_result)) == FAIL) {
  469.  
  470.       mp_error = MP_VECTOR_LENGTH_FAILED;
  471.     }
  472.     break;
  473.  
  474.       case MP_VECTOR_REF :
  475.  
  476.     if ((result_status = vector_ref(MPPH_arg1, MPPH_arg2, 
  477.                     MPPH_result)) == FAIL) {
  478.  
  479.       mp_error = MP_VECTOR_REF_FAILED;
  480.     }
  481.     break;
  482.  
  483.       case MP_ASSIGN :
  484.  
  485. DEBUG(DBG_PARG("MP_ASSIGN:cdr of stack","%d ",*(((plural natural *plural) OA_data(MPPH_context_stack)) + 1)));
  486.  
  487. DEBUG(fprintf(dbg,"arg1:%d: ",arg1);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg1)));
  488. DEBUG(fprintf(dbg,"arg2:%d: ",arg2);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg2)));
  489.  
  490.     OA_offsets(MPPH_arg1) = OA_offsets(MPPH_arg2);
  491.     result_status = SUCCESS;
  492.     return_value = arg1;
  493.  
  494. DEBUG(fprintf(dbg,"arg1:%d: ",arg1);DBG_PARG("*:","%d ",OA_offsets(MPPH_arg1)));
  495.  
  496. DEBUG(DBG_PARG("MP_ASSIGN:cdr of stack","%d ",*(((plural natural *plural) OA_data(MPPH_context_stack)) + 1)));
  497.  
  498.     break;
  499.  
  500.       case MP_VECTOR_SET :
  501.  
  502.     if ((result_status = vector_merge(MPPH_arg1, MPPH_arg2,
  503.                     MPPH_arg3)) == FAIL) {
  504.  
  505.       mp_error = MP_VECTOR_SET_FAILED;
  506.     }
  507.     return_value = arg1;
  508.     break;
  509.     
  510.       case MP_VECTOR_MERGE :
  511.  
  512.     if ((result_status = vector_merge(MPPH_arg1, MPPH_arg2, 
  513.                       MPPH_result)) == FAIL) {
  514.  
  515.       mp_error = MP_VECTOR_MERGE_FAILED;
  516.     }
  517.     break;
  518.  
  519.     
  520.       case MP_REF :    
  521.  
  522.     /* arg1 is the address of an MP_Plural handle             */
  523.     /* arg2 is the element to be set.               */
  524.     /* The result is the processor id the element was one     */
  525.  
  526.     mp_error = MP_GREEN;
  527.  
  528.     if ((arg2 < 0) || ((int)arg2 >= (OA_width(MPC_context) *
  529.                      OA_height(MPC_context)))) {
  530.  
  531.       result_status = FAIL;
  532.       mp_error = MP_INDEX_OUTSIDE_PLURAL;
  533.     }
  534.     else {
  535.  
  536.       return_value = OM_first(MPC_context)+(arg2 % OA_width(MPC_context)) +
  537.         (PP_nxproc * (arg2 / OA_width(MPC_context)));
  538.  
  539.       if (PP_iproc == ((int) return_value)) {
  540.         
  541.         scratch[0] = 1;
  542.         encode(MPPH_arg1);
  543.       }
  544.       GC_UnProtect(1);
  545.       return ((return_value*2)+PP_left_right_proc);
  546.     }
  547.     break;
  548.  
  549.       case MP_SET :
  550.  
  551.     /* arg1 is the address an MP_Plural handle                */
  552.     /* arg2 is the element of the plural to be set            */
  553.  
  554.     if ((arg2 < 0) || ((int)arg2 >= (OA_width(MPC_context) *
  555.                      OA_height(MPC_context)))) {
  556.  
  557.       result_status = FAIL;
  558.       mp_error = MP_INDEX_OUTSIDE_PLURAL;
  559.     }
  560.     else {
  561.  
  562.       return_value = OM_first(MPC_context)+(arg2 % OA_width(MPC_context)) +
  563.         (PP_nxproc * (arg2 / OA_width(MPC_context)));
  564.       if (PP_iproc == (int)return_value) {
  565.  
  566.         if ((result_status = fe_decode( MPPH_arg1, arg3 )) == FAIL) {
  567.         
  568.           mp_error = MP_BUILD_STRUCTURE_FAIL;
  569.         }
  570.         return_value  = arg1;
  571.       }
  572.     }
  573.     break;
  574.  
  575.       case MP_BANG :
  576.  
  577.     /* arg1 is the address of an front end description buffer */
  578.       
  579.     if ((result_status = fe_decode( MPPH_result, arg1 )) == FAIL) {
  580.       
  581.       mp_error = MP_BUILD_STRUCTURE_FAIL;
  582.     }
  583.     break;
  584.  
  585.     default :
  586.  
  587.       result_status = FAIL;
  588.       }
  589.     }
  590.   }   /* matches: OM_with_context() */
  591.   }   /* matches: PP_on_set()       */
  592.  
  593.   if (result_status != FAIL) {
  594.  
  595.     if (return_value == NULL) {
  596.  
  597.       /* Operation was a success but we don;t know what to return      */
  598.       /* Assume a result has been put into MPPH_result, need to create */
  599.       /* a new plural to wrap around it                                */
  600.  
  601.       PP_on_set() return_value = alloc_plural(MPC_context);
  602.  
  603.       if (return_value == FAIL) {
  604.  
  605. DBG_FAIL(fprintf(dbg,"FAIL: Unable to create plural for result, op id = %d",operation_id));
  606. DBG_EROR(MP_ALLOC_PLURAL_FAILED);
  607.       }
  608.       
  609.       PP_on_set() {
  610.     OM_with_context(MPC_context) MPPH_2_MPP(return_value,MPPH_result);
  611.       }
  612.     }
  613.   }
  614.   else {
  615.  
  616.     GC_UnProtect(1);
  617. DBG_FAIL(fprintf(dbg,"FAIL: Some error occurred, see mp_error, op id=%d",operation_id));
  618.     return FAIL;
  619.   }
  620.  
  621.   GC_UnProtect(1);
  622. DBG_EXIT(fprintf(dbg,"SUCCESS"));
  623.   return return_value;
  624. }
  625.  
  626. /*----------------------------------------------------------------------------*
  627.  * Function   : mp_init_plural
  628.  *
  629.  * Parameters : void
  630.  *
  631.  * Description:    Preforms any initialisation required, most importantly
  632.  *        tells the front end where the PE scratch space is for the
  633.  *        the purposes of communication via blockOut.
  634.  *
  635.  * Result     : char *:    Address of PE scratch space
  636.  *            NULL if some failure occurs
  637.  *---------------------------------------------------------------------------*/
  638.  
  639. #ifdef __STDC__
  640.  
  641. visible char *mp_init_plural( void )
  642.  
  643. #else
  644.  
  645. visible char *mp_init_plural( )
  646.  
  647. #endif
  648.  
  649. {
  650.   MP_PluralHeap MPPH_true;
  651.   plural natural tmp;
  652.   MP_PluralHeap MPPH_tmp = &tmp;
  653.  
  654. DBG_CALL("mp_init_plural");
  655.  
  656.   init_debug();
  657.  
  658. DBG_ARGS(fprintf(dbg,"void"));
  659.  
  660.   plural_memory = (plural natural *plural) heap_memory;
  661.  
  662.   init_proc_pair();
  663.  
  664.   /*  allocate, nil an t on each PE. These are special symbols with
  665.    *  special addresses and identifiers 
  666.    */
  667.  
  668.   if (mp_alloc((plural int) MP_SYMBOL, (plural int) 1, MPPH_tmp) == FAIL) {
  669. DBG_FAIL(fprintf(dbg,"Unable to allocate nil!!!!"));
  670.     return FAIL;
  671.   }
  672.  
  673.   *(plural int *plural) OA_data(MPPH_tmp) = MP_NIL_ID;
  674.  
  675.   if (mp_alloc((plural int) MP_SYMBOL, (plural int) 1, MPPH_tmp) == FAIL) {
  676. DBG_FAIL(fprintf(dbg,"Unable to allocate t!!!!)"));
  677.   }
  678.  
  679.   *(plural int *plural) OA_data(MPPH_tmp) = MP_T_ID;
  680.  
  681.   private_nproc = nproc;
  682.   if (nproc != MASPAR_CONFIG) {
  683.  
  684. DBG_EROR(MP_WRONG_MASPAR_CONFIG);
  685.   }
  686.  
  687. DBG_EXIT(fprintf(dbg,"%x",(char *)scratch));
  688.   return scratch;
  689. }
  690.  
  691.  
  692. /*  
  693.  *  Communications
  694.  *  ==============
  695.  *
  696.  *  These functions allow the user to define maps between sets of conformant
  697.  *  plurals and move data along, in the fashion of paralation lisp
  698.  *
  699.  */
  700.  
  701. /*----------------------------------------------------------------------------*
  702.  * Function   : mp_match
  703.  *
  704.  * Parameters : object MPC_dest:    Destination Context
  705.  *        int    dest:        Destination Plural
  706.  *        object MPC_from:    Source Context
  707.  *        int    dest:        Source Plural
  708.  *
  709.  * Description: Creates a map between two contexts (not necesdsarily different)
  710.  *        Using equality between the two plurals to define which
  711.  *        elements of the source context are used to create each
  712.  *        element of the destination context.
  713.  *        The map has the form of a list of processor ids for each
  714.  *        element of the destination context
  715.  *
  716.  * Result     : int:    Resulting map plural
  717.  *---------------------------------------------------------------------------*/
  718.  
  719. #ifdef __STDC__
  720.  
  721. visible int mp_match( object MPC_dest, int dest,
  722.               object MPC_from, int from )
  723. #else
  724.  
  725. visible int mp_match( MPC_dest, dest, MPC_from, from )
  726.  
  727. object MPC_dest;
  728. int    dest;
  729. object MPC_from;
  730. int    from;
  731.  
  732. #endif
  733.  
  734. {
  735.   int first,i;
  736.   int map;
  737.   int aok = TRUE;
  738.   plural int to_values;
  739.   plural int to_types;
  740.   plural int from_values = -1;
  741.   int from_value;
  742.   plural int from_types;
  743.   int from_type;
  744.   plural natural result = NIL;
  745.   MP_PluralHeap MPPH_result = &result;
  746.   plural natural number = NIL;
  747.   MP_PluralHeap MPPH_number = &number;
  748.   MP_PluralHeap MPPH_from;
  749.   MP_PluralHeap MPPH_dest;
  750.   plural natural context;
  751.   MP_PluralHeap MPPH_context = &context;
  752.   MP_PluralHeap MPPH_context_stack;
  753.  
  754. DBG_CALL("mp_match");
  755. DBG_ARGS(fprintf(dbg,"MPC_dest=%x,dest=%d,MPC_from=%x,from=%d", MPC_dest, 
  756.          dest, MPC_from, from ));
  757.   set_gc_message();
  758.   GC_Protect(result);
  759.   GC_Protect(number);
  760.   
  761.   /* Convert to plural heap handles */
  762.  
  763.   MPP_2_MPPH(MPPH_dest,dest);
  764.   MPP_2_MPPH(MPPH_from,from);
  765.  
  766.   PP_on_set() {
  767.  
  768.   /* Check these are both plurals of integers and or symbols */
  769.  
  770.   OM_with_context(MPC_from) {
  771.  
  772.     if (globalor((OA_info(MPPH_from) != INTEGER) && (OA_info(MPPH_from) != MP_SYMBOL))) {
  773.  
  774.       aok      = FALSE;
  775.       mp_error = MP_MAP_SOURCE_NOT_INTS;
  776. DBG_FAIL(fprintf(dbg,"FAIL: Source plural is not all integers"));
  777.     }
  778.  
  779.     from_values = *(plural int *plural) OA_data(MPPH_from);
  780.     from_types  = OA_info(MPPH_from);
  781.   }
  782.  
  783.   if (aok) {
  784.  
  785.     OM_with_context(MPC_dest) {
  786.  
  787.       if (globalor((OA_info(MPPH_dest) != INTEGER) && (OA_info(MPPH_dest) != MP_SYMBOL))) {
  788.  
  789.     aok      = FALSE;
  790.     mp_error = MP_MAP_DEST_NOT_INTS;
  791. DBG_FAIL(fprintf(dbg,"FAIL: Destination plural is not all integers"));
  792.       }
  793.  
  794.       MPP_2_MPPH(MPPH_context_stack, OA_offset(MPC_dest));
  795.       if (car(MPPH_context_stack, MPPH_context) == FAIL) {
  796. DBG_FAIL(fprintf(dbg,"FAIL: Unable to take car of context stack"));
  797.     mp_error = MP_CAR_OF_CONTEXT_FAIL;
  798.     return FAIL;
  799.       }
  800.  
  801.       if (context != NIL) {
  802.  
  803.     to_values = *(plural int *plural) OA_data(MPPH_dest);
  804.     to_types  = OA_info(MPPH_dest);
  805.       
  806.     first = OM_first(MPC_from);
  807.     i = 0;
  808.     while (((first + i) <= OM_last(MPC_from)) && aok) {
  809.       
  810.       from_value = PP_proc(first + i).from_values;
  811.       from_type  = PP_proc(first + i).from_types;
  812.  
  813.       if ((to_values == from_value) && (to_types == from_type)) {
  814.  
  815. DEBUG(DBG_PARG("iproc","%d ",iproc));
  816. DEBUG(fprintf(dbg,"from_value=%d",from_value));
  817.  
  818.         if ((aok == mp_alloc((plural int) INTEGER,
  819.                  (plural int) 1, MPPH_number)) != FAIL) {
  820.  
  821.           *(plural int *plural) OA_data(MPPH_number) = i+first;
  822.           aok = cons(MPPH_number, MPPH_result, MPPH_result);
  823.         }
  824.       }
  825.       i = i + 1;
  826.       if (i == OA_width(MPC_from)) {
  827.         i = 0;
  828.         first = first + PP_nxproc;
  829.       }
  830.     }
  831.       }
  832.     }
  833.   }
  834.     
  835.   if (aok) {
  836.  
  837.     if ((map = alloc_plural(MPC_dest, 0)) == FAIL) {
  838.  
  839.       aok = FALSE;
  840.       mp_error = MP_ALLOC_PLURAL_FAILED;
  841. DBG_FAIL(fprintf(dbg,"FAIL: Unable to create plural for map"));
  842.     }
  843.  
  844.     else OM_with_context(MPC_dest) MPPH_2_MPP(map,MPPH_result);
  845.   }
  846.   }                                                  /* matches: PP_on_set() */
  847.  
  848.   GC_UnProtect(2);
  849.   if (!aok) return FAIL;
  850.  
  851. DBG_EXIT(fprintf(dbg,"%d",map));
  852.   return map;
  853. }
  854.  
  855.  
  856. /*----------------------------------------------------------------------------*
  857.  * Function   : mp_move
  858.  *
  859.  * Parameters : object MPC_data:    Context of data
  860.  *        int    data:         Plural containing data to be moved
  861.  *        object MPC_map:        Context of map
  862.  *        int    map:        The map
  863.  *        int    initial_value:    List of things already moved
  864.  *                    to this PE
  865.  *
  866.  * Description: Moves data down a map, this gives a new plural , conformant to
  867.  *        the destination plural where each element contains a list of
  868.  *        the objects from the source destination which were mapped
  869.  *        to that location
  870.  *        The addition of initial_value, is to make life easier
  871.  *        in the virtual array case where several moves have
  872.  *        to be done in order to get all the onjects to a given
  873.  *        location. This means we can easily accumulate the
  874.  *        the results in a single list rather than creating 
  875.  *        several that then have to be merged.
  876.  *
  877.  * Result     : int:    FAIL/SUCCESS
  878.  *---------------------------------------------------------------------------*/
  879.  
  880. #ifdef __STDC__
  881.  
  882. visible int mp_move( object MPC_data, int data, object MPC_map, 
  883.              int map, int initial_value )
  884.  
  885. #else
  886.  
  887. visible int mp_move( MPC_data, data, MPC_map, map, initial_value )
  888.  
  889. object MPC_data;
  890. int data;
  891. object MPC_map;
  892. int map;
  893. int initial_value;
  894.  
  895. #endif
  896.  
  897. {
  898.   int aok = TRUE;
  899.   MP_PluralHeap MPPH_data;
  900.   plural natural tmp;
  901.   MP_PluralHeap MPPH_tmp = &tmp;
  902.   plural natural natural_map = NIL;
  903.   MP_PluralHeap MPPH_map = &natural_map;
  904.   MP_PluralHeap MPPH_result;
  905.   plural natural natural_car = NIL;
  906.   MP_PluralHeap MPPH_car = &natural_car;
  907.   plural int procids = iproc;
  908.   plural int index;
  909.   plural char buf;
  910.   int i;
  911.  
  912. DBG_CALL("mp_move");
  913. DBG_ARGS(fprintf(dbg,"MPC_data=%x,data=%d,MPC_map=%x,map=%d,initial=%d",
  914.               MPC_data,data,MPC_map,map,initial_value));
  915.   set_gc_message();
  916.   GC_Protect(tmp);
  917.   GC_Protect(natural_map);
  918.   GC_Protect(natural_car);
  919.  
  920.   MPP_2_MPPH(MPPH_data,data);
  921.   MPP_2_MPPH(MPPH_result,initial_value);
  922.   PP_on_set() {
  923.  
  924.   OM_with_context(MPC_map) OA_offsets(MPPH_map) = plural_memory[map];
  925.  
  926.   while ((globalor(OA_offsets(MPPH_map) != NIL)) && (aok)) {
  927.  
  928.     scratch[0] = 1;
  929.     OM_with_context(MPC_data) encode(MPPH_data);
  930.  
  931.     if (OA_offsets(MPPH_map) != NIL) {
  932.  
  933. DEBUG(DBG_PARG("*MPPH_map","%d ",OA_offsets(MPPH_map)));
  934. DEBUG(DBG_PARG("*MPPH_result","%d ",OA_offsets(MPPH_result)));
  935.  
  936.       if ((aok = car(MPPH_map, MPPH_car)) == FAIL) {
  937.  
  938.     mp_error = MP_CAR_OF_MAP_FAILED;
  939. DBG_FAIL(fprintf(dbg,"Unable to take car of map"));
  940.       }
  941.       else if ((aok = cdr(MPPH_map,MPPH_map)) == FAIL) {
  942.  
  943.     mp_error = MP_CDR_OF_MAP_FAILED;
  944. DBG_FAIL(fprintf(dbg,"Unable to take cdr of map"));
  945.       }
  946.       else {
  947.  
  948.     procids = *(plural int *plural) OA_data(MPPH_car);
  949.       
  950.     for (i=0; i<SCRATCH_MEMORY_SIZE; i++) {
  951.  
  952.       buf = PP_router(procids).scratch[i];
  953.       scratch[i] = buf;
  954.     }
  955.  
  956.     index = 1;
  957.     if ((aok = decode(MPPH_tmp, &index)) == FAIL) {
  958.  
  959.       mp_error = MP_DECODE_IN_MOVE_FAILED;
  960. DBG_FAIL(fprintf(dbg,"FAIL: decode stage of move failed"));
  961.         }
  962.  
  963.     if ((aok = cons(MPPH_tmp, MPPH_result, MPPH_result)) == FAIL) {
  964.  
  965.       mp_error = MP_CONS_COLLISIONS_FAILED;
  966. DBG_FAIL(fprintf(dbg,"FAIL: Unable to cons up collisions"));
  967.     }
  968.       }
  969.     }
  970.   }
  971.   if (!aok) {
  972. DBG_FAIL(fprintf(dbg,"FAIL: mp_error=%d",mp_error));
  973. }
  974.   else {
  975. DBG_EXIT(DBG_PARG("SUCCESS: *MPPH_result","%d ",OA_offsets(MPPH_result)));
  976. }
  977.   }
  978.  
  979.   GC_UnProtect(3);
  980.   if (!aok) return FAIL;
  981.   return SUCCESS;
  982. }
  983.        
  984.  
  985. /*  CM Hacks
  986.  *  == =====
  987.  *
  988.  *  Whilst trying to write a quick version if CM Lisp for the MasPar I 
  989.  *  discovered that although it could be done a few extra functions 
  990.  *  paricularly in the communication section woule be useful. The
  991.  *  first useful thing was something to help calculate intersections of
  992.  *  the index xec. I am (as usual) working with integers only!
  993.  *
  994.  *  A second version oif CM-Lisp followd the implementation used by Steele
  995.  *  in particular the rendezvous mechanism is used. This eliminates the
  996.  *  need for cm_identify, two new functions are used instead. The first
  997.  *  cm_put is probably worth hacking into eubang at some stage. The second,
  998.  *  cm_start, is a useful optimisation when working out where to "put" things
  999.  */
  1000.  
  1001. /*----------------------------------------------------------------------------*
  1002.  * Function   : cm_put
  1003.  *
  1004.  * Parameters : object MPC_data:    The context of the data to be putted
  1005.  *        int    data:        The offset  of the data to be putted
  1006.  *        int    dest:        The procids to put the dat too
  1007.  *        object MPC_dest:    The context of the resulting plural
  1008.  *        
  1009.  * Description: This is a function created for the CM Lisp interpreter, it 
  1010.  *        performs an operation which is analagous to an inverse of move
  1011.  *        But no collisions can occurr
  1012.  *
  1013.  * Result     : visible int: The offset of the resulting plural
  1014.  *---------------------------------------------------------------------------*/
  1015.  
  1016. #ifdef __STDC__
  1017.  
  1018. visible int cm_put( object MPC_data, int data, int dest, object MPC_dest )
  1019.  
  1020. #else
  1021.  
  1022. visible int cm_put( MPC_data, data, dest, MPC_dest )
  1023.  
  1024. object MPC_data;
  1025. int data;
  1026. int dest;
  1027. object MPC_dest;
  1028.  
  1029. #endif
  1030.  
  1031. {
  1032.   int i;
  1033.   plural int buf;
  1034.   plural char c_buf;
  1035.   plural int index;
  1036.   plural int *plural scratch_in_ints = (plural int *plural) scratch;
  1037.   int aok = TRUE;
  1038.   plural int dest_proc_ids = PP_iproc;
  1039.   plural int from_proc_ids = -1;
  1040.   plural int dest_proc_p   = FALSE;
  1041.   MP_PluralHeap MPPH_dest;
  1042.   MP_PluralHeap MPPH_data;
  1043.   plural natural nil = NIL;
  1044.   MP_PluralHeap MPPH_nil = &nil;
  1045.   int result_offset;
  1046.   plural natural result = NIL;
  1047.   MP_PluralHeap MPPH_result = &result;
  1048.  
  1049. DBG_CALL("cm_put");
  1050. DBG_ARGS(fprintf(stderr,"MPC_data=%x,data=%d,MPC_dest=%x,dest=%d",
  1051.                  MPC_data,data,MPC_dest,dest));
  1052.   set_gc_message();
  1053.   GC_Protect(nil);
  1054.   GC_Protect(result);
  1055.  
  1056.   MPP_2_MPPH(MPPH_data,data);
  1057.   MPP_2_MPPH(MPPH_dest,dest);
  1058.  
  1059.   PP_on_set() {
  1060.  
  1061.     OM_with_context(MPC_data) {
  1062.  
  1063.       dest_proc_ids = *(plural int *plural) OA_data(MPPH_dest);
  1064.       PP_router(dest_proc_ids).from_proc_ids = PP_iproc;
  1065.     }
  1066.  
  1067.     if ((from_proc_ids > -1) && (from_proc_ids < PP_nproc)) dest_proc_p = TRUE;
  1068.     else from_proc_ids = PP_iproc;
  1069.     scratch[0] = 1;
  1070.     OM_with_context(MPC_data) encode(MPPH_data);
  1071.  
  1072.     for (i=0; i<SCRATCH_MEMORY_SIZE/sizeof(int); i++) {
  1073.  
  1074.       buf = PP_router(from_proc_ids).scratch_in_ints[i];
  1075.       scratch_in_ints[i] = buf;
  1076.     }
  1077.  
  1078.     index = 1;
  1079.  
  1080.     if (dest_proc_p) {
  1081.  
  1082.       if ((aok = decode(MPPH_result, &index)) == FAIL) {
  1083.  
  1084. DBG_FAIL(fprintf(dbg,"FAIL: error whilst decoding - no space?"));
  1085.       }
  1086.       else if ((aok = cons(MPPH_result, MPPH_nil, MPPH_result)) == FAIL) {
  1087.  
  1088. DBG_FAIL(fprintf(dbg,"FAIL: unable to cons up putted objects"));   
  1089.       }
  1090.     }
  1091.  
  1092.     if (aok && ((aok = result_offset = alloc_plural(MPC_dest, 0)) != FAIL)) {
  1093.  
  1094.       OM_with_context(MPC_dest) plural_memory[result_offset] = result;
  1095.     }
  1096.     else {
  1097.  
  1098. DBG_FAIL(fprintf(dbg,"FAIL: Unable to create plural for putted objects"));
  1099.     }
  1100.   }
  1101.   GC_UnProtect(2);
  1102.   if (!aok) return FAIL;
  1103.  
  1104.   return result_offset;
  1105. }
  1106.     
  1107. /*----------------------------------------------------------------------------*
  1108.  * Function   : cm_start
  1109.  *
  1110.  * Parameters : object MPC_context:    An MasPar Context object
  1111.  *
  1112.  * Description: We are interested in where the context starts, this will allow
  1113.  *        to move data from the rendezvous into it without having to do
  1114.  *        an expensive match operation
  1115.  *
  1116.  * Result     : int: The processor id
  1117.  *---------------------------------------------------------------------------*/
  1118.  
  1119. #ifdef __STDC__
  1120.  
  1121. visible int cm_start( object MPC_context )
  1122.  
  1123. #else
  1124.  
  1125. visible int cm_start( MPC_context )
  1126.  
  1127. object MPC_context;
  1128.  
  1129. #endif
  1130.  
  1131. {
  1132.   return OM_first(MPC_context);
  1133. }
  1134.